home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Pascal Super Library
/
Pascal Super Library (CW International)(1997).bin
/
DELPHI32
/
DEBUG
/
STAKWK10
/
STAKLOW.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1996-05-10
|
6KB
|
258 lines
unit StakLow;
{ Low level Delphi 2.0 debugger fix unit. Copyright (c) 1996, D.J. Murdoch }
{ THIS VERSION IS NOT FOR DISTRIBUTION!!!! }
{$D- We don't want this code to be reported }
{$OPTIMIZATION off } { And we don't want it optimized }
interface
uses classes,sysutils;
type
EDebug = class(Exception);
TRange = class
start, stop : integer;
end;
TRangeList = class(TList)
{ This is a list of ranges of addresses to report }
destructor destroy; override;
procedure FreeAll;
{ Frees all the ranges }
function InRange(target:pointer):boolean;
{ Checks whether start <= target <= stop
for some entry in the list }
procedure ReadMapFile(filename:string);
{ Reads a .MAP file to initialize }
procedure HandleException(Sender: TObject; E: Exception);
{ Possible handler for Application.OnException }
end;
procedure ExceptHandler(ExceptObject: TObject; ExceptAddr: Pointer);
{ Handler to use in place of ExceptProc }
procedure WalkStack;
{ Walks through the stack, triggering an EDebug exception at everything that
looks as though it might be a return address }
type
TContinueFunc = function:boolean;
TWarnProc = procedure;
var
StackWalker : TRangeList;
FoundMap : boolean;
StopWalker : boolean;
WalkerActive : boolean;
ContinueFunc : TContinueFunc;
Walking : boolean;
implementation
procedure TRangeList.FreeAll;
var
i : integer;
begin
for i:=0 to pred(count) do
TRange(Items[i]).Free;
Count := 0;
end;
destructor TRangeList.Destroy;
begin
FreeAll;
inherited;
end;
function TRangeList.InRange(target:pointer):boolean;
var
i : Integer;
begin
result := false;
for i:=0 to pred(count) do
with TRange(Items[i]) do
if (start <= integer(target)) and (integer(target) <= stop) then
begin
result := true;
exit;
end;
end;
procedure TRangeList.ReadMapFile(filename:string);
var
map : textfile;
line : string;
range : TRange;
mapshift : integer;
buffer : array[1..8192] of byte;
begin
mapshift := 0;
FreeAll;
assignfile(map,filename);
settextbuf(map,buffer);
{$i-}
reset(map);
{$i+}
if ioresult = 0 then
begin
while not eof(map) do
begin
readln(map,line);
if pos('Publics by Value',line) > 0 then
break;
end;
while not eof(map) do
begin
readln(map,line);
if pos('TextStart',line) > 0 then
begin
mapshift := integer(@TextStart) - StrToInt('$'+copy(line,7,8));
break;
end;
end;
while not eof(map) do
begin
readln(map,line);
if pos('Line numbers for ',line) > 0 then
begin
range := TRange.Create;
readln(map,line);
if line = '' then
readln(map,line);
range.start := mapshift + StrToInt('$'+copy(line,13,8));
range.stop := mapshift + StrToInt('$'+copy(line,length(line)-7,8));
while not eof(map) do
begin
readln(map,line);
if line = '' then
break;
range.stop := mapshift + StrToInt('$'+copy(line,length(line)-7,8));
end;
Add(range);
end;
end;
closefile(map);
end;
if count = 0 then
begin
FoundMap := false;
range := TRange.create;
range.start := integer(@TextStart);
range.stop := integer(@HeapAllocFlags);
Add(range);
end
else
FoundMap := true;
end;
procedure WalkStack;
var
target : pointer;
hitnum : integer;
saveclass : TClass;
p,stackstart,stacktop : ^pointer;
begin
if walking then
exit;
stopwalker := false;
walking := true;
saveclass := ExceptionClass;
asm
mov stackstart,esp
end;
ExceptionClass := Nil; { Run until we hit the top of the stack, but don't
let the debugger know about it. }
p := stackstart;
try
repeat
target := p^;
inc(p);
until false;
except
stacktop := p;
end;
ExceptionClass := SaveClass;
hitnum := 0;
p := stackstart;
try
while (not StopWalker) and (integer(p) < integer(stacktop)) do
begin
ExceptionClass := Nil;
target := p^;
ExceptionClass := saveclass;
if stackwalker.inrange(target) then
begin
if assigned(ContinueFunc) and not ContinueFunc then
break;
inc(hitnum);
if hitnum > 0 then
try
raise edebug.create(format('Hit number %d at %x, %d%% done',
[hitnum,integer(target),
((integer(p)-integer(stackstart))*100) div
(integer(stacktop)-integer(stackstart))]))
at target;
except
end;
end;
inc(p);
end;
except
end;
walking := false;
end;
type
thandler = procedure(ExceptObject: TObject; ExceptAddr: Pointer);
var
saveexcept : thandler;
procedure fpuinit; assembler;
const cwDefault: Word = $1332 { $133F};
begin
asm
FNINIT
FWAIT
FLDCW cwDefault
end;
end;
procedure ExceptHandler(ExceptObject: TObject; ExceptAddr: Pointer);
begin
{ fpuinit; }
if WalkerActive then
WalkStack;
saveexcept(ExceptObject,ExceptAddr);
end;
procedure TRangeList.HandleException(Sender: TObject; E: Exception);
begin
{ fpuinit; }
ShowException(E,ExceptAddr);
if WalkerActive then
WalkStack;
end;
initialization
saveexcept := THandler(ExceptProc);
if debughook <> 0 then
begin
stackwalker := TRangeList.Create;
FoundMap := false;
stackwalker.readmapfile(ChangeFileExt(paramstr(0),'.map'));
ExceptProc := @ExceptHandler;
ContinueFunc := nil;
WalkerActive := true;
Walking := false;
end
else
StackWalker := Nil;
finalization
ExceptProc := @saveexcept;
stackwalker.free;
end.